perm filename PARSE.FLP[1,LMM] blob sn#029040 filedate 1973-03-10 generic text, type T, neo UTF8
  (PROGN (LISPXPRIN1 (QUOTE "FILE CREATED ")
                     T)
         (LISPXPRIN1 (QUOTE "10-MAR-73 09:59:00")
                     T)
         (LISPXTERPRI T))
  (LISPXPRINT (QUOTE PARSEVARS)
              T)
  (RPAQQ PARSEVARS
         ((FNS UNPARSE UNPARSELT PACKRAT PACKRAT1 PARSE NUMPARSE PARSE1 
               PARSE← BI12 PARSEAT PACKLDIFF BISET BIRPLAC)
          (VARS)
          (ADVISE STRPOSL)))
(DEFINEQ

(UNPARSE
  [LAMBDA (PAT)
    (MAPCONC PAT (FUNCTION UNPARSELT])

(UNPARSELT
  [LAMBDA (PATELT)
    (COND
      ((NLISTP PATELT)
        (SELECTQ PATELT
                 (($1 $ *)
                   (LIST PATELT))
                 PATELT))
      (T
        (SELECTQ
          (CAR PATELT)
          (DEFAULT (LIST (CDR PATELT)))
          [$$ (COND
                ((AND (NUMBERP (CDR PATELT))
                      (IGREATERP (CDR PATELT)
                                 1))
                  (PACKRAT (QUOTE $)
                           (CDR PATELT)))
                (T (LIST (CAR PATELT)
                         (CDR PATELT]
          ((= == ')
            (PACKRAT (CAR PATELT)
                     (CDR PATELT)))
          [ANY (LIST (CONS (CAR PATELT)
                           (UNPARSE (CDR PATELT]
          (←(NCONC [PACKRAT (CADR PATELT)
                            (CAR PATELT)
                            (CAR (SETQ TEM (UNPARSELT (CDDR PATELT]
                   (CDR TEM)))
          [-> (NCONC (UNPARSELT (CDDR PATELT))
                     (PACKRAT (QUOTE ←)
                              (CADR PATELT]
          [! (SELECTQ (CADR PATELT)
                      (←(PACKRAT (QUOTE !)
                                 (QUOTE ←)
                                 (CDDR PATELT)))
                      (NCONC [PACKRAT (QUOTE !)
                                      (CAR (SETQ TEM
                                             (UNPARSELT (CDR PATELT]
                             (CDR TEM]
          (LIST (UNPARSE PATELT])

(PACKRAT
  [LAMBDA N
    (PROG ((CNT N)
           VAL ATLST)
      LP  (COND
            ((ZEROP CNT)
              (RETURN (PACKRAT1 ATLST VAL)))
            ((NLISTP (ARG N CNT))
              (SETQ ATLST (CONS (ARG N CNT)
                                ATLST)))
            (T (SETQ VAL (CONS (ARG N CNT)
                               (PACKRAT1 ATLST VAL)))
               (SETQ ATLST)))
          (SETQ CNT (SUB1 CNT))
          (GO LP])

(PACKRAT1
  [LAMBDA (ATLST LST)
    (COND
      (ATLST (CONS (PACK ATLST)
                   LST))
      (T LST])

(PARSE
  [LAMBDA (PAT)
    (PROG (NUMLIST)

          (* NUMLIST is a list of the #'s that have been found 
          -
          For every # that is found, an entry is added to 
          NUMLIST which is (NUMBER %. Pattern where the NUMBER 
          occured) so that later, NUMPARSE can go back and 
          change the numbered item to 
          (← (## . I) item) and thus, the thing can be saved.
          In MAKEMATCH, the thing-that-matched item will 
          either be bound to a variable, or passed along)


          (SETQ PAT (PARSE1 PAT))
          (COND
            (NUMLIST (NUMPARSE NUMLIST)))
          (RETURN PAT])

(NUMPARSE
  [LAMBDA (PAT NUMLIST)
    (OR (NOT NUMLIST)
        (HELP "NUMBERS NOT DONE YET" PAT])

(PARSE1
  [LAMBDA (PAT BACKPAT)

          (* Smashes PAT with it's parsing;
          BACKPAT is used when there is a ← to determine if 
          the previous thing was a !, a variable, or a pattern 
          -
          If it was VAR or !, leave it alone & ignore it -
          If it was a pattern, then don't PARSE the next 
          thing, since it's an EXPRESSION -
          In the first two cases, BACKPAT should be T;
          otherwise, it should be)



          (* GODDAM IT -- THIS THING NEEDS TO DO THE RIGHT 
          THING WITH !←'S. I GUESS IT SHOULD BE 
          (!←FOO) GOES TO (!-> FOO) AND 
          (!VAR←) GOES TO (! ← VAR); IT COULD BE, THOUGH, THAT 
          ONE COULD DO (!← FOO ...) GOES TO 
          (! -> FOO . ...) (I.E., GLOM ONTO REST OF PATTERN) -
          AND (!FOO← ...) GOES TO (! ← FOO . ...) 
          (DITTO) -
          ANYWAY , PARSE DOESNT DO EITHER RIGHT NOW!!!!!!!)


    (AND PAT
         (PROG (TEM)
           RETRY
               [COND
                 [(NLISTP (CAR PAT))
                   (SELECTQ (CAR PAT)
                            ((= ==)

          (* Look for ←'s in (CADR PAT) and spread it out if 
          so -
          This might want to change later -
          (= foo←fie ...) -
          (=foo ←fie ...) -
          (=foo←fie ...) -
          The second case is not ambiguous, but the first is -
          it's possible to handle it just like the QUOTE -
          Never split -
          Or leave it to PARSEAT never to split after an equal 
          -
          Also, need it for the (admittedly rare) case of # 
          1←foo)


                              (PARSE←
                                (CDR PAT))      (* And then "BI" CAR & 
                                                CDR PAT)
                              (BI12 PAT))
                            (($$ #)
                              (PARSE←
                                (CDR PAT))
                              (BI12 PAT)
                              (SETQ NUMLIST (CONS (CAR PAT)
                                                  NUMLIST)))
                            [$ (PARSE←
                                 (CDR PAT))
                               (COND
                                 ((EQ (CADR PAT)
                                      (QUOTE 1))
                                   (RPLACA PAT (QUOTE $1))
                                   (RPLACD PAT (CDDR PAT)))
                                 ((SMALLP (CADR PAT))
                                   (BI12 PAT)
                                   (RPLACA (CAR PAT)
                                           (QUOTE $$]
                            ('                  (* NO ←'S ALLOWED OR 
                                                CHECKED FOR)
                              (BI12 PAT))
                            (($ ≠ -- & $1 ≠1 * !)
                                                (* These are all ok -
                                                ! will be handled later)
                              T)
                            [←(COND
                                ((NOT BACKPAT)
                                  (PARSE1 (CDDR PAT))
                                  (RETURN PAT]
                            (COND
                              ((AND (STRPOSL (QUOTE (! ' ≠ & - # ←
                                                                = $))
                                             (CAR PAT)
                                             1)
                                    (PARSEAT (DUNPACK (CAR PAT)
                                                      SKORLST2)
                                             PAT))
                                                (* Otherwise, BREAK up 
                                                CAR PAT and try to 
                                                PARSEAT it)
                                (GO RETRY))
                              (T                (* Must have a variable 
                                                here!)
                                 (SETQ TEM (QUOTE VAR]
                 ((EQ (CAAR PAT)
                      (QUOTE ANY))
                   (PARSE1 (CDAR PAT)))
                 (T                             (* Otherwise, all there 
                                                is is a subpattern)
                    (PARSE1 (CAR PAT]
               [AND (CDR PAT)
                    (NLISTP (CDR PAT))
                    (RPLACD PAT (LIST (QUOTE !)
                                      (CDR PAT]
               (PARSE1 (CDR PAT)
                       TEM)
               [COND
                 [(EQ (CADR PAT)
                      (QUOTE ←))
                   (COND
                     ((EQ (CAR PAT)
                          (QUOTE !))            (* Got (!←expr ...) 
                                                change it to 
                                                ((! ← . expr) ...))
                       (RPLACD PAT (CDDR PAT))
                       (RPLACA PAT (QUOTE !->))
                       (BI12 PAT))
                     ((EQ TEM (QUOTE VAR))

          (* Got (VAR ← PAT ...); change it to 
          ((← VAR . PAT) ...))


                       (BISET PAT))
                     (T 

          (* Otherwise, there is a (PAT ← EXPR ...); change it 
          to (-> expr . PAT))


                        (BIRPLAC PAT]
                 ((EQ (CAR PAT)
                      (QUOTE !))
                   (BI12 PAT))
                 ((EQ TEM (QUOTE VAR))
                   (RPLACA PAT (CONS (QUOTE DEFAULT)
                                     (CAR PAT]
               (RETURN PAT])

(PARSE←
  [LAMBDA (PAT)                                 (* Look for ←'s in 
                                                (CAR PAT))
    (AND (LITATOM (CAR PAT))
         (PARSEAT (DUNPACK (CAR PAT)
                           SKORLST2)
                  PAT
                  (QUOTE (←])

(BI12
  [LAMBDA (PAT)                                 (* This changes 
                                                (A B ...) to 
                                                ((A . B) ...))
    (COND
      ((OR (NLISTP PAT)
           (NLISTP (CDR PAT)))
        (ERROR "BAD ARG TO BI12" PAT)))
    (PROG ((TEM (CDR PAT)))
          (RPLACD PAT (CDDR PAT))
          (RPLACD TEM (CAR TEM))
          (RPLACA TEM (CAR PAT))
          (RPLACA PAT TEM])

(PARSEAT
  [LAMBDA (UNPACKEDAT PAT FLG)

          (* Parses (CAR PAT) which has been unpacked into 
          UNPACKEDAT and replaces the parsing into 
          (CAR PAT); otherwise return if can't -
          Unless flg is on, meaning always smash 
          (CAR PAT))


    (PROG (TAIL AT REST)
          (RETURN (COND
                    ([SETQ TAIL
                        (SOME UNPACKEDAT
                              (FUNCTION (LAMBDA (CHR)
                                  (FMEMB CHR
                                         (QUOTE (' = ←
                                                     * $ # %. ! ']
                      (SETQ AT (CAR TAIL))
                      [SETQ REST (COND
                          ((AND (EQ (CAR TAIL)
                                    (QUOTE =))
                                (EQ (CADR TAIL)
                                    (QUOTE =)))
                            (SETQ AT (QUOTE ==))
                            (CDDR TAIL))
                          ([AND (EQ (CAR TAIL)
                                    (QUOTE $))
                                (EQ (CADR TAIL)
                                    1)
                                (NOT (SMALLP (CADDR TAIL]
                                                (* $1's are parsed as an
                                                atom)
                            (SETQ AT (QUOTE $1))
                            (CDDR TAIL))
                          ((AND (EQ (CAR TAIL)
                                    (QUOTE $))
                                (EQ (CADR TAIL)
                                    (QUOTE $)))
                            (SETQ AT (QUOTE $$))
                            (CDDR TAIL))
                          (T (CDR TAIL]
                      (COND
                        (REST (PARSEAT REST PAT T)
                              (ATTACH AT PAT))
                        (T (RPLACA PAT AT)))
                      (AND (NOT (EQ TAIL UNPACKEDAT))
                           (ATTACH (PACKLDIFF UNPACKEDAT TAIL)
                                   PAT))
                      PAT)
                    (FLG (RPLACA PAT (PACK UNPACKEDAT])

(PACKLDIFF
  [LAMBDA (L TAIL)
    (PROG (TEM)
          (AND (SETQ TEM (NLEFT L 1 TAIL))
               (RPLACD TEM)
               (PROG1 (PACK L)
                      (RPLACD TEM TAIL])

(BISET
  [LAMBDA (PAT)

          (* This function changes (a b c ...) to 
          ((b a . c) ...))


    (PROG ((TEM (CDR PAT)))
          (RPLACD PAT (CDDDR PAT))
          (RPLACD (CDR TEM)
                  (CADR TEM))
          (RPLACA (CDR TEM)
                  (CAR PAT))
          (RPLACA PAT TEM])

(BIRPLAC
  [LAMBDA (PAT)
    (PROG ((TEM (CAR PAT)))
          (RPLACA PAT (CDR PAT))
          (RPLACD PAT (CDDDR PAT))
          (RPLACD (CDAR PAT)
                  TEM)
          (RPLACA (CAR PAT)
                  (QUOTE ->])
)
(DEFLIST(QUOTE(
  [STRPOSL (NIL (AFTER NIL (PROGN (RADIX 10)
                                  (PRINTLEVEL 1000)
                                  (CONTROL 0)
                                  (CONTROL T]
))(QUOTE READVICE))

  (READVISE STRPOSL)
STOP